perm filename PGSUB.F4[PAG,LCS]7 blob
sn#496812 filedate 1980-01-29 generic text, type T, neo UTF8
00100 C**** VARIOUS SUBROUTINES FOR PAGE LAYOUT PROGRAM. ****
00200
00300 SUBROUTINE FILOUT(NAMQ,NPG)
00400 COMMON /FIN/JBAR,NPX,REND,KPX,KREAD,JEND,JSLUR,JSL2,NAMZ
00500 1,LC,LPG,MPG,CLEF,SIG,LB,SPG,MTR1,MTR2
00600 1 /SF/KL,RT,KP,STFSZ,NAMX,EXT /IVV/NUMS(1)
00700 2 FORMAT(' TYPE FILE NAME '$)
00800 102 FORMAT(A5)
00900 103 TYPE 2
01000 CALL READX(5,NAMX,EXT,NPG,NUMS)
01100 CC103 CALL NAMEXT(EXT)
01200 IF(NAMX.NE.' ')GO TO 1
01300 EXT='TST'
01400 NAMX='AAAAA'
01500 1 NAMZ=NAMX
01600 NPG=1
01700 IF(LOOKX(NAMX,EXT).GE.0)RETURN
01800 CC IF(LOOKX(NAMX,EXT).GE.0)GO TO 88
01900 TYPE 88,NAMX,EXT
02000 ACCEPT 102,L
02100 IF(L.EQ.'N')GO TO 103
02200 88 FORMAT(' WRITE OVER FILE ',A5,'.',A3,'???? '$)
02300 END
02400
02500 SUBROUTINE FILEIN
02600 COMMON /FIN/JBAR,NPX,REND,KPX,KREAD,JEND,JSLUR,JSL2,NAMZ
02700 1,LC,LPG,MPG,CLEF,SIG,LB,SPG,MTR1,MTR2 /IPG/IPG,JPG,
02800 1 BRACK(0/7),RSTNUM(8),RPSZ(8),RHGT(8),RCLEF(0/7)
02900 1 /RSP/KNM(1) /ENDL/ENDLN,N,NAME,NMPG,T /KBAR/KBAR(515)
03000 COMMON RS,JA,CLEFQ,AA,RQ(16),KQ,NQ,JQ,JJQ,KBQ,NAQ
03100 COMMON /POSI/STFF(0/7),JJ2,JPQ /LLL/L,LL,I,RXQ
03200 COMMON/STF/RSTFAC(0/7),RSTJ2 /PX/KPN(1) /Q/Q(1)
03300 1 /NBAR/NBAR(1)
03400 EQUIVALENCE (LASTNM,KBAR(3))
03500
03600 CCC IF(NMPG.EQ.'PAGEA')NPZ='PAGEZ'
03700 IF(NBAR(LC).EQ.0)CALL EXIT
03800 IF(KPX.EQ.1)GO TO 104
03900 C SKIP THIS FIRST TIME. IT SHUFFLES DATA FORWARD IN ARRAY.
04000 J=KPX-1
04100 JJ=KPN(KPX)-1
04200 DO 105 K=1,NPX-J
04300 105 KPN(K)=KPN(K+J)-JJ
04400 J=KPN(NPX)-JJ
04500 C HOW MUCH TO SHIFT THE Q ARRAY
04600 CX DO 106 K=1,J
04700 CX106 Q(K)=Q(K+JJ)
04800 CALL RLOOP(Q,Q(JJ+1),J)
04900 KPX =NPX-KPX+1
05000 C UPDATE POINTERS FOR NEXT READIN
05100 KQ=KPN(KPX)
05200 JPX=KQ-1
05300
05400 104 KL=1
05500 KP=1
05600 JEND=0
05700 C FLAG FOR PAGE END - WHEN -1
05800 IF(LB.LT.NBAR(LC))GO TO 220
05900 NPX=KPX
06000 KPX=1
06100 LB=0
06200 GO TO 241
06300 220 CALL GETEXT(NMPG,'PAG')
06400 CALL EXTIN(RSTFAC,22)
06500 211 CALL EXTIN(KPN(KPX),JJ2)
06600 CALL EXTIN(Q(KQ),JPQ)
06700 JP=JJ2+KPX
06800 IF(JP.LE.450)GO TO 1211
06900 TYPE 3211,JP
07000 STOP
07100 3211 FORMAT(' ARRAY OVERLOAD. KPN=',I3,'/450')
07200 4211 FORMAT(' ARRAY OVERLOAD. Q=',I4,'/4500')
07300 1211 JP=KQ+JPQ
07400 IF(JP.LE.4500)GO TO 2211
07500 TYPE 4211,JP
07600 STOP
07700 2211 IF(KPX.EQ.1)GO TO 140
07800 CC IF(KPX.EQ.LPX)GO TO 311
07900 C AVOIDS DOUBLE METERS, I HOPE!
08000 CC IF(Q(KQ+1).NE.18)GO TO 311
08100 C LOOK AT FIRST NEW ITEM, IS IT A METER?
08200 CC KPX=LPX
08300 CC KQ=KPN(KPX)
08400 C YES, GO BACK AND READ OVER OLD METERS.
08500 CC JPX=KQ-1
08600 CC GO TO 220
08700 311 OLD=Q(KPN(KPX-1)+3)
08800 B=0
08900 JJ=JJ2+KPX-1
09000 DO 420 JP=KPX,JJ
09100 K=KPN(JP)+JPX
09200 KPN(JP)=K
09300 R=Q(K+1)
09400 IF(B.NE.0)GO TO 420
09500 IF(R.LE.2)GO TO 620
09600 IF(R.NE.18)GO TO 420
09700 CHECK UP ON METER DUPLICATE.
09800 DO 720 KK=KPX-1,1,-1
09900 R=CODEN(KPN,KK,Q,LA)
10000 720 IF(R.NE.18)GO TO 820
10100 GO TO 420
10200 820 IF(KK.EQ.KPX-1)GO TO 420
10300 KPX=KK+1
10400 KQ=KPN(KPX)
10500 JPX=KQ-1
10600 C GO BACK AND READ OVER DANGLING METER
10700 GO TO 220
10800 620 B=Q(K+3)
10900 C B=POS OF FIRST NOTE OR REST IN NEW FILE.
11000 DO 1 KK=KPX,JP
11100 R=CODEN(KPN,KK,Q,LA)
11200 IF(R.NE.44)GO TO 7
11300 IF(Q(LA+6).EQ.0.OR.Q(LA).LT.4)GO TO 1
11400 C LOOK AT LINES, CRESC, DASHES, WIGGLES ONLY.
11500 GO TO 2
11600 7 IF(R.NE.7)GO TO 5
11700 IF(Q(LA).LT.5)GO TO 1
11800 RR=ABS(Q(LA+7))
11900 IF(RR.GT.1.AND.RR.LT.8)GO TO 1
12000 C AVOID PEDAL MARKS.
12100 GO TO 2
12200 5 IF(R.NE.5)GO TO 1
12300 C FOUND SLUR INTO LEFT SIDE OF LINE
12400 IF(Q(LA+3))Q(LA+3)=B-5
12500 A=Q(LA+6)
12600 C=Q(LA+2)
12700 2 DO 3 NN=1,KPX-1
12800 RR=CODEN(KPN,NN,Q,II)
12900 IF(RR.NE.R)GO TO 3
13000 IF(Q(II).LT.4)GO TO 3
13100 IF(Q(II+3).GT.D)GO TO 3
13200 IF(Q(II+2).NE.C)GO TO 3
13300 C CATCHES ONLY ONE SLUR(ETC.) POS PER STAFF!!
13400 IF(Q(II+6).LT.D)GO TO 3
13500 Q(II+6)=A
13600 C ADJUSTS PARAM 6 TO POSITION IN NEW FILE.
13700 GO TO 1
13800 3 CONTINUE
13900 1 CONTINUE
14000 420 CONTINUE
14100 140 JPX=KQ+JPQ-3
14200 C NUM OF WORDS TO SHIFT.
14300 LPX=KPX
14400 C SO IT WON'T GET CONFUSED
14500 41 NMPG=NMPG+2
14600 C NMPG = NAME OF INPUT FILES
14700 IF(NMPG.EQ.'PAGEZ'+2)NMPG='PAGFA'
14800 C WILL GO FROM PAGEA TO PAGFZ, ETC. (104) ADD TO THIS IF NEEDED.
14900 IF(NMPG.EQ.'PAGFZ'+2)NMPG='PAGGA'
15000 IF(NMPG.EQ.'PAGGZ'+2)NMPG='PAGHA'
15100 CCC IF(NMPG.LE.NPZ)GO TO 2242
15200 CCC NPZ=NPZ+256
15300 CCC NMPG='PAGFA'
15400 CC L=JJ2-2
15500 CC NPX=KPX+L
15600 2242 NPX=KPX+JJ2-2
15700 241 JBAR=NBAR(LC)
15800
15900 DO 20 JP=KPX,NPX-1
16000 R=CODEN(KPN,JP,Q,N)
16100 CC N=KPN(JP) R=Q(N+1)
16200 IF(R.NE.4)GO TO 20
16300 C FINDS BAR LINES IN THIS PART OF DATA
16400 LB=LB+1
16500 IF(LB.NE.JBAR)GO TO 20
16600 KPX=JP+1
16700 D=Q(N+3)
16800 DO 121 L=JP-1,1,-1
16900 R=CODEN(KPN,L,Q,N)
17000 IF(R.NE.5)GO TO 121
17100 RR=Q(N+6)
17200 IF(RR.LT.D)GO TO 121
17300 Q(N+6)=-1
17400 C=Q(N+2)
17500 B=0
17600 DO 221 KK=JP+1,NPX-1
17700 R=CODEN(KPN,KK,Q,NN)
17800 IF(R.NE.1)GO TO 221
17900 IF(Q(NN+2).NE.C)GO TO 221
18000 C CHECK ON STAFF NUM.
18100 A=Q(NN+3)-1
18200 IF(RR.LT.A)GO TO 221
18300 B=B-1
18400 IF(ABS(RR-A).LE.2)GO TO 321
18500 C IF IT'S CLOSE ENOUGH CALL IT EQUAL.
18600 221 CONTINUE
18700 321 IF(B)Q(N+6)=B
18800 121 CONTINUE
18900 C SAVE POS OF LAST BAR FOR SLUR CONNECTIONS, ETC.
19000 CC LPX=KPX
19100 C SAVE POINTER IN CASE OF DOUBLE METERS.
19200 20 CONTINUE
19300 IF(LB.GE.JBAR)GO TO 520
19400 KPX=NPX
19500 KQ=JPX+1
19600 GO TO 220
19700 520 KQ=Q(KPN(KPX)+1)
19800 CIRC IF(KQ.NE.18.AND.KQ.NE.44)GO TO 120
19900 IF(KQ.NE.18.AND.KQ.NE.44.AND.KQ.NE.3)GO TO 120
20000 CC520 IF(Q(KPN(KPX)+1).NE.18)GO TO 120
20100 C LOOKS FOR CLEF, METER OR SECONDARY BAR LINES(44) BEYOND LAST BAR IN LINE.
20200 IF(KPX.GE.NPX)GO TO 10
20300 KPX=KPX+1
20400 GO TO 520
20500 120 IF(NPX.LE.KPX)GO TO 10
20600 KK=KPX-1
20700 R=Q(KPN(KK)+3)+.5
20800 DO 11 K=KK,NPX
20900 IF(Q(KPN(K)+3).GT.R)GO TO 12
21000 11 KPX=K
21100 C ABOVE CATCHES THINGS IN SAME POS. AS LAST BAR LINE.
21200 12 IF(KPX.LT.NPX)KPX=KPX+1
21300 10 KQ=KPN(KPX)
21400 LB=LB-JBAR
21500 L=KPX-1
21600 C L=TOTAL ITEMS FOR THIS LINE. JBAR=TOTAL BARS, LB=HOW MANY LEFT OVER
21700 I=L
21800 IF(LB.NE.0)RETURN
21900 KPX=1
22000 KQ=1
22100 END
22200
22300 SUBROUTINE STAVES
22400 COMMON /FIN/JBAR,NPX,REND,KPX,KREAD,JEND,JSLUR,JSL2,NAMZ
22500 1,LC,LPG,MPG,CLEF,SIG,LB,SPG,MTR1,MTR2/RSIG/RSIG(0/7)
22600 COMMON /SF/KL,RT,KP,STFSZ,NAMX /IPG/IPG,JPG,BRACK(0/7),
22700 1 RSTNUM(8),RPSZ(8),RHGT(8),RCLEF(0/7)
22800 1 /RSP/KNM(1) /ENDL/ENDLN,N,NAME,NMPG,T /KBAR/KBAR(515)
22900 COMMON RS,JA,CLEFQ,AA,RQ(16),KQ,NQ,JQ,JJQ,KBQ,NAQ
23000 1 /STF/RSTFAC(0/7),RSTJ2 /IVV/OSLUR(1)
23100 COMMON /POSI/STFF(0/7),JJ2,JPQ /LLL/L,LL,I,RXQ
23200 1/PX/KPN(1) /Q/Q(1) /PTR/KWDS(1) /XRN/RN(1) /NBAR/NBAR(1)
23300 DIMENSION ENDSTF(450),STFNM(0/7)
23400 C ENDSTF AND ENDPTR FOR CARRYING STUFF FROM ONE LINE TO THE NEXT.
23500 EQUIVALENCE (RQ(2),R4),(R5,RQ(3)),(R6,RQ(4)),(R7,RQ(5))
23600 1,(ENDSTF,KBAR(4))
23700 1,(R8,RQ(6)),(R9,RQ(7)),(STFNM,KBAR(508))
23800 DATA SLSP/12.0/
23900 IF(LC.EQ.1)RA=0
24000 C RA IS LEFT POS OF Q DATA. (IT SHIFTS AS LC CHANGES.)
24100 KL=1
24200 KP=1
24300 LC=LC+1
24400 335 RX=0
24500 IF(NBAR(LC).EQ.0)JEND=-1
24600 3 JJ=KP
24700
24800 C ******** PUTS IN STAFF ********
24900 RS=3.
25000 C RS IS WDCNT FOR SUBR. STAFF
25100 IF(RT.EQ.0)RS=6
25200 C =6 FOR BOTTOM STAFF. PUTS IN SPACER.
25300 CC331 IF(IPG)GO TO 411
25400 HX=8
25500 G=0
25600 RX=RT
25700 DO 611 JP=1,LPG
25800 RT=RSTNUM(JP)
25900 LA=RT
26000 RS=3
26100 C WD CNT IS RS, HX IS CODE(8), ARRAYS AND LPG(JPG) WERE SET UP IN MAIN.
26200 RR=0
26300 IF(NAMX.EQ.NAMZ)GO TO 11
26400 IF(RT.NE.0)GO TO 11
26500 RS=6
26600 RR=SPG
26700 C FOR SPACER ON STAFF 0
26800 11 IF(STFNM(LA).NE.0)RS=7
26900 611 CALL STAFF(RS,HX,G,RHGT(JP),RPSZ(JP),G,G,RR,STFNM(LA),G,G,G)
27000 C STFNM IS INST. NAME IN P9 OF STAFF PARAMS.
27100 HX=LPG
27200 IF(IPG)GO TO 6
27300 RS=4.
27400 RT=0
27500 CALL STAFF(2.,RS,G,HX,G,G,G,G,G,G,G,G)
27600 DO 1611 JP=1,LPG
27700 RT=RSTNUM(JP)
27800 LA=RT
27900 BR=BRACK(LA)
28000 IF(BR.EQ.0)GO TO 1611
28100 R7=AMOD(BR,100.)
28200 R4=(BR-R7)/100.
28300 CALL STAFF(5.,RS,G,R4,G,G,R7,G,G,G,G,G)
28400 1611 CONTINUE
28500 RT=RX
28600 CC GO TO 511
28700 CC411 CALL STAFF(RS,8.,0,HGT,RSTJ2,0,0,SP,SP,SP,SP,SP)
28800 CC HGT=HGT-HX
28900 CI511 IF(JEND)GO TO 60
29000 C FOR PREMATURE PAGE END
29100 CP IF(K.NE.I)GO TO 6
29200 CI IF(RT.EQ.0)GO TO 6
29300 CI60 IF(IPG.EQ.0)GO TO 6
29400 CI RX=RT
29500 CI RT=0
29600 CI CALL STAFF(6.,8.,0,0,0,0,1.,SP,SP,SP,SP,SP)
29700 C PUTS IN SPACER
29800 CI RT=RX
29900
30000 C ****** NEXT FOR CLEFS ************
30100 6 RX=1
30200 IF(CLEF.EQ.-99)GO TO 33
30300 C ONLY STAFF FOR FIRST LINE AT TOP.
30400 RX=8.*RSTJ2
30500 C THE SPACER
30600 CC LA=0
30700 CC IF(IPG)GO TO 3011
30800 LA=LPG
30900 3111 RT=RSTNUM(LA)
31000 LL=RT
31100 CLEF=RCLEF(LL)
31200 C GETS CLEF FOR PAGE LAYOUT, RT IS STAFF# IN CALL
31300 LA=LA-1
31400 3011 IF(CLEF.NE.99)CALL STAFF(3.,3.,1.5,0,CLEF,0,0,0,0,0,0,0)
31500 IF(SIG.EQ.-99)GO TO 3211
31600 C ***** NEXT FOR KEY SIG. ********
31700 RS=4.
31800 R5=RSIG(LL)
31900 332 IF(R5.NE.99)CALL STAFF(RS,17.,10.*RSTJ2,0,R5,CLEF,0,0,0,0,0,0)
32000 3211 IF(LA.GT.0)GO TO 3111
32100 RX=11.*RSTJ2
32200 C RX SETS POS OF NEXT ITEM ON STAFF
32300 R7=RX
32400
32500 33 LA=1
32600 KX=0
32700 61 IF(ENDSTF(LA).EQ.0)GO TO 31
32800 C JUMP IF NO CARRYOVERS FROM PREVIOUS LINE.
32900 R5=ENDSTF(LA+1)
33000 IF(R5.NE.18)GO TO 261
33100 CHECK UP ON METER FROM PREV. LINE. AVOID DUPLICATE.
33200 DO 361 KK=1,I
33300 R=CODEN(KPN,KK,Q,LL)
33400 IF(R.EQ.4)GO TO 261
33500 C JUMP IF METER FOUND BEFORE 1ST BAR LINE.
33600 361 IF(R.EQ.18)GO TO 161
33700 261 RT=ENDSTF(LA+2)
33800 IF(R5.NE.18)GO TO 461
33900 IF(KX)GO TO 461
34000 KX=-1
34100 RX=RX+4
34200 IF(ENDSTF(LA).GT.4)RX=RX+5
34300 461 CALL STAFF(ENDSTF(LA),ENDSTF(LA+1),ENDSTF(LA+3),ENDSTF(LA+4),
34400 1 ENDSTF(LA+5),ENDSTF(LA+6),ENDSTF(LA+7),ENDSTF(LA+8),
34500 1 ENDSTF(LA+9),ENDSTF(LA+10),ENDSTF(LA+11),ENDSTF(LA+12))
34600 161 LA=LA+13
34700 GO TO 61
34800
34900 C RX SPACES NEXT ITEM TO RIGHT OF LINE BEGINNING.
35000 31 R4=Q(KPN(I)+3)
35100 C GET POS OF LAST ITEM FOR THIS LINE
35200 DO 32 K=1,I
35300 32 IF(Q(KPN(K)+3).LT.R4)R4=Q(KPN(K)+3)
35400 C ALL THIS NEEDED BECAUSE OF GRACE NOTE AT START OF LINE PROBLEM.
35500
35600 IF(RA.LT.R4)RA=R4
35700 R4=RA-.1
35800 C -.1 FOR ROUND-OFF ERRORS
35900 LA=I
36000 DO 831 K=1,I
36100 KK=KPN(K)+3
36200 C FIND SLURS ETC. BEFORE 1ST NOTES OR REST. (NOT NEG.)
36300 IF(Q(KK).GE.RA)GO TO 231
36400 831 Q(KK)=0
36500 231 RA=CODEN(KPN,LA,Q,K4)
36600 IF(RA.EQ.4)GO TO 131
36700 IF(RA.NE.44)GO TO 931
36800 IF(Q(K4).LE.2)GO TO 131
36900 CATCHES BAR LINES ON UPPER STAVES.
37000 931 LA=LA-1
37100 GO TO 231
37200 131 RA=Q(K4+3)
37300 R5=RA+.001
37400 C +.001 IS TO CATCH SLIGHT ROUNDOFF ERRORS WHEN CODE 44 IS LAST ITEM.
37500 DO 731 K=1,I
37600 CC KK=KPN(K) R=Q(KK+1)
37700 R=CODEN(KPN,K,Q,KK)
37800 IF(R.EQ.44)GO TO 631
37900 IF(R.EQ.7)GO TO 631
38000 IF(R.NE.5)GO TO 731
38100 631 IF(Q(KK).LT.4)GO TO 731
38200 R=Q(KK+6)
38300 IF(R.LT.R5)GO TO 731
38400 C R5 = LEFT SIDE OF ITEM NOW, R= RIGHT SIDE.
38500 Q(KK+6)=R5
38600 C CATCHES RIGHT SIDE OF THINGS FOR MOVER. (PEDS?)
38700 731 CONTINUE
38800 RS=-1
38900 C -1 SO ALL STAVES WILL MOVE AT ONCE.
39000 CC RS=0
39100 R7=0
39200 C R7=0 FOR GETPTS TO LOOK AT ALL STAVES.
39300 R8=RX
39400 R9=200.
39500 LL=0
39600 L=I
39700 CALL PTMOVE(Q,KPN)
39800 IF(LA.EQ.I)RETURN
39900 C NEXT PUTS METER JUST BEYOND END OF LINE
40000 R=202
40100 R7=Q(KPN(LA+1)+3)
40200 C R7 HOLDS STAFF NUM. FOR THINGS BEYOND END OF LINE.
40300 DO 531 K5=LA+1,I
40400 K7=KPN(K5)
40500 K4=0
40600 IF(Q(K7+1).EQ.18)K4=Q(K7+5)*100+Q(K7+6)
40700 C K4 STORES METER (TOP*100+BOTTOM)
40800 IF(Q(K7+3).EQ.R7)GO TO 531
40900 R7=Q(K7+3)
41000 C THIS PROBABLY WON'T ALWAYS DO THE RIGHT THING!!
41100 R=R+5
41200 CM IF(MTR1.GT.0.AND.K4.NE.0)MTR2=K4
41300 531 Q(K7+3)=R
41400 CM431 Q(K7+3)=R
41500 CM531 IF(K4.NE.0.AND.MTR1)MTR1=K4
41600 END
41700